home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / hacks.lisp < prev    next >
Encoding:
Text File  |  1991-06-20  |  5.2 KB  |  177 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-HACKS; -*-
  2. ; File hacks.lisp / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ; Things that both the translator and the runtime system need.  For
  5. ; level-crossing to work (i.e. EVAL), these things must be shared
  6. ; between the two; for bootstrapping an incompatible system they must
  7. ; not be shared.
  8.  
  9. ; ----- Cope with vagaries of #+ in VAX LISP
  10.  
  11. (lisp:in-package "SCHEME-HACKS" :use '("LISP"))
  12.  
  13. (export '(
  14.       ;; Things used by the translator and by the runtime system
  15.       intern-renaming-perhaps    ;code generator
  16.       qualified-symbol-p
  17.       make-photon
  18.       photon-p            ;rep loop
  19.  
  20.       ;; Things used by runtime system
  21.       find-symbol-renaming-perhaps
  22.       lisp-package
  23.       scheme-package
  24.       scheme-readtable
  25.       *non-scheme-readtable*
  26.       fix-scheme-package-if-necessary
  27.       clever-load
  28.       ))
  29.  
  30. (eval-when (eval load compile)
  31.   (when (find-if #'(lambda (feature)
  32.              (and (symbolp feature)
  33.               (string= (symbol-name feature) "DEC")))
  34.          *features*)
  35.     (pushnew ':DEC *features*)))
  36.  
  37. ; ----- Photons
  38.  
  39. ; "A ``photon'' is an object that PRIN1's as if it had been PRINC'ed."
  40. ;                       -- KMP
  41. ;
  42. ; Photons are used by the runtime system to make the unspecified and
  43. ; unassigned objects and to produce values to be returned by DEFINE
  44. ; forms.  Photons are used by the translator to generate code that has
  45. ; #+, #-, and #. forms in it.
  46.  
  47. (defstruct (photon (:constructor make-photon (string-or-function))
  48.            (:copier nil)
  49.            (:print-function print-photon))
  50.   string-or-function)
  51.  
  52. (defun print-photon (photon stream escape?)
  53.   (declare (ignore escape?))
  54.   (let ((z (photon-string-or-function photon)))
  55.     (if (stringp z)
  56.     (princ z stream)
  57.     (funcall z stream))))
  58.  
  59. ; ----- The SCHEME package:
  60.  
  61. ; It's important that scheme symbols print as SCHEME::FOO when the
  62. ; Scheme package is not current.
  63.  
  64. (defvar scheme-package)
  65.  
  66. (defun qualified-symbol-p (sym)
  67.   (and (symbolp sym)
  68.        (not (eq (symbol-package sym) scheme-package))))
  69.  
  70. (defun pollutedp (package)
  71.   (do-symbols (sym package)
  72.     (when (qualified-symbol-p sym) (return-from pollutedp t))))
  73.  
  74. (defun fix-scheme-package-if-necessary (package)
  75.   (setq scheme-package package)
  76.   (if (not (equal (package-name package) "SCHEME"))
  77.       (rename-package package "SCHEME"))
  78.   (cond ((pollutedp package)
  79.      (purify-scheme-package package))))
  80.  
  81. ; Things about whose EQ-ness we care:
  82.  
  83. (defparameter losers
  84.   '("DEFINE"
  85.     "ELSE" "=>" "UNQUOTE" "UNQUOTE-SPLICING"
  86.     "HEUR" "B" "O" "D" "X"))
  87.  
  88. (defun purify-scheme-package (package)
  89.   (format t "~&Purifying...")
  90.   (let ((*package* package))            ;help circumvent slime bugs
  91.     (let ((lisp-package (find-package "LISP"))
  92.       (winners (mapcar #'(lambda (name)
  93.                    (intern name package))
  94.                losers)))
  95.       (unuse-package (package-use-list package) package)
  96.       (import winners package)
  97.       (do-symbols (sym package)
  98.     (cond ((eq (symbol-package sym) package)
  99.            (unexport sym package)
  100.            ;; OK, do nothing.
  101.            )
  102.           ((eq sym (find-symbol (symbol-name sym) lisp-package))
  103.            (let ((name (symbol-name sym)))
  104.          (if (member name losers :test #'string=)
  105.              (error "~S shouldn't be accessible in the LISP package, but it is."
  106.                 sym))
  107.          (unintern sym package)
  108.          (let ((new-sym (intern name package)))
  109.            (assert (eq (symbol-package new-sym) package)
  110.                () "Lost on ~S" new-sym)
  111.            (symbol-forward sym new-sym))))
  112.           (t
  113.            (purify-symbol sym package)))))))
  114.  
  115. ; Clobber the symbol's home package so that it prints
  116. ; as SCHEME::FOO.
  117. (defun purify-symbol (sym package)
  118.   (unexport sym package)
  119.   (let ((name (symbol-name sym))
  120.     (old-package (symbol-package sym)))
  121.     (format t " ~S" sym)
  122.     (unexport sym old-package)
  123.     (unintern sym old-package)            ;?
  124.     (import sym package)
  125.     #+Lispm                    ;?
  126.     (setf (symbol-package sym) package)
  127.     (multiple-value-bind (hucairz status)
  128.     (find-symbol name old-package)
  129.       (declare (ignore hucairz))
  130.       (unless status    ;inherited
  131.     (import sym old-package)))
  132.     (unless (and (eq sym (find-symbol name package))
  133.          (eq (symbol-package sym) package))
  134.       (format t "~& (Failed to move ~S to ~A package)~%"
  135.           sym
  136.           (package-name package)))))
  137.  
  138. (defun symbol-forward (from-sym to-sym)
  139.   (when (boundp from-sym)
  140.     (setf (symbol-value to-sym) (symbol-value from-sym))
  141.     (proclaim `(special ,to-sym)))
  142.   (cond ((or (special-form-p from-sym)
  143.          (macro-function from-sym))
  144.      (setf (macro-function to-sym)
  145.            #'(lambda (form env)
  146.            (declare (ignore env))
  147.            (cons from-sym (cdr form)))))
  148.     ((fboundp from-sym)
  149.      (setf (symbol-function to-sym)
  150.            (symbol-function from-sym)))))
  151.  
  152. ; ----- The LISP package:
  153.  
  154. (defparameter lisp-package
  155.   (find-package #-:DEC "LISP" #+:DEC "COMMON-LISP"))
  156.  
  157. (defun lisp-symbol? (string)
  158.   ;; Good candidate for caching
  159.   (multiple-value-bind (sym status)
  160.       (find-symbol string lisp-package)
  161.     (declare (ignore sym))
  162.     (eq status :external)))
  163.  
  164. (defun intern-renaming-perhaps (string package)
  165.   (intern (if (or (eq package scheme-package)
  166.           (not (lisp-symbol? string)))
  167.           string
  168.           (concatenate 'simple-string "." string))
  169.       package))
  170.  
  171. (defun find-symbol-renaming-perhaps (string package)
  172.   (find-symbol (if (or (eq package scheme-package)
  173.                (not (lisp-symbol? string)))
  174.            string
  175.            (concatenate 'simple-string "." string))
  176.            package))
  177.